Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/codeli/code.lib

INI File | 1994-05-01 | 50.1 KB | 1,687 lines

[1]
FrameControl is used to draw frames around controls. Pass it: the name of the form, the name of the control, the offset, and the width of the frame. 5 is a good offset, 1 or 2 a good width.


[Code]
'Declares for FrameControl
Global Const HiColor = &HFFFFFF
Global Const LoColor = &H808080

Sub FrameControl (F As Form, C As Control, OffSet As Integer, Width As Integer)
F.DrawWidth = Width
F.forecolor = &HFFFFFF

'bottom:
    F.Line (C.Left, C.Top + C.Height + Offset)-(C.Left + C.Width, C.Top + C.Height + Offset)
'right:
    F.Line (C.Left + C.Width + Offset, C.Top)-(C.Left + C.Width + Offset, C.Top + C.Height + Offset)
    F.forecolor = &H808080
'top:
    F.Line (C.Left - Offset * 1.5, C.Top - Offset * 1.5)-(C.Left + C.Width + Offset * 1.5, C.Top - Offset * 1.5)
'left:
    F.Line (C.Left - Offset * 1.5, C.Top - Offset * 1.5)-(C.Left - Offset * 1.5, C.Top + C.Height + Offset)
End Sub

[Stop]
[2]
GetSysDir returns the path of the Windows System directory

Pass it the name of the string you want SysPath assigned to.

[Code]
'Declares for GetSystemDir
Declare Function GetSystemDirectory Lib "Kernel" (ByVal lpBuffer As String, ByVal nSize As Integer) As Integer

Sub GetSystemDir (SystemPath$)
DIM Sys As String * 256
   x = GetSystemDirectory(Sys, Len(Sys))
   x = InStr(1, Sys, Chr$(0))
   SystemPath$ = Left$(Sys, Instr(Sys,Chr$(0))-1)
End Sub

[Stop]
[3]
CenterForm centers the form passed to it horizontally and vertically on the screen.
[Code]
Sub CenterForm (F As Form)
F.Left = (Screen.Width - F.Width) / 2
F.Top = (Screen.Height - F.Height) / 2
End Sub
[Stop]
[4]
Loaded tells if an app of the passed classname is loaded

[Code]
'Declares for Loaded
Declare Function FindWindow Lib "user" (ByVal CName As Any, ByVal Caption As Any)

Function Loaded (ClassName$)
    Loaded = FindWindow(ClassName$, 0&)
End Function

[Stop]
[5]
Wait "secs" bfore returning  to call, allows vb to finish an executed command.

[Code]
Sub WaitSecs (secs)
Dim sTart!, Temp%
    start! = Timer
    While Timer < start! + secs +1
         Temp% = DoEvents()
    Wend
End Sub

[Stop]
[6]
RestoreApp restores the windows whose handle you pass to it.

[Code]
'Declares for RestoreApp
Declare Function IsIconic Lib "user" (ByVal hWnd As Any)

Sub RestoreApp (wHandle)

WM_SYSCOMMAND = &H112
SC_RESTORE = &HF120
  If IsIconic(Instance) Then
    T = PostMessage(Instance, WM_SYSCOMMAND, SC_RESTORE, 0)
    WaitSecs 1
  End If

End Sub

[Stop]
[7]
Tracks a popup menu.

Pass it the number (going from right to left) of the menu you wish to view, the X & Y coordinates at which it should pop up (as returned by a mousedown event), the form on which the mousedown event took place (and over which the menu should appear), and the form to which the menu belongs (which may or may not be the same as the previous form).

[Code]
'TrackPopupMenu declares
Declare Function TrackPopupMenu% Lib "user" (ByVal hMenu%, ByVal wFlags%, ByVal X%, ByVal Y%, ByVal r2%, ByVal hWnd%, ByVal r1&)
Declare Function GetMenu% Lib "user" (ByVal hWnd%)
Declare Function GetSubMenu% Lib "user" (ByVal hMenu%, ByVal nPos%)


Sub TrackPopUp (Menu As Integer, X As Single, Y As Single, F as Form, MenuForm As Form)
Const PIXEL = 3
Const TWIP = 1
      F.ScaleMode = PIXEL
      InPixels = F.ScaleWidth
      F.ScaleMode = TWIP
          ix = (X + F.Left) \ (F.ScaleWidth \ InPixels)
          iy = (Y + (F.Top + (F.Height - F.ScaleHeight - (F.Width - F.ScaleWidth)))) \ (F.ScaleWidth \ InPixels)
          hMenu% = GetMenu(MenuForm.hWnd)
          hSubMenu% = GetSubMenu(hMenu%, Menu)
          '2 tells it to use right mouse button, 1 the left button
      r = TrackPopupMenu(hSubMenu%, 2, ix, iy, 0, MenuForm.hWnd, 0)
End Sub

[Stop]
[8]
MakeBeep beeps the PC's speaker a specified number of times
[Code]
Sub MakeBeep (Reps%)
For X=1 to Reps%
     Beep
Next
End Sub
[Stop]
[9]
Extracts icons from a specified Exe file.


[Code]
'Declares for IconExtractor
Const GWW_HINSTANCE = (-6)
Declare Function GetWindowWord Lib "User" (ByVal hWnd As Integer, ByVal nIndex As Integer) As Integer
Declare Function ExtractIcon Lib "shell" (ByVal lpHandle As Integer, ByVal lpExe As String, ByVal lpiconindex As Integer) As Integer
Declare Function DrawIcon Lib "USER" (ByVal lpHandle As Integer, ByVal xcoord As Integer, ByVal ycoord As Integer, ByVal Hicon As Integer) As Integer

Sub IconExtractor (ExeFile$, F as Form, Pic as Picture)
Handle = F.hWnd
z = SCREEN.HEIGHT
    Select Case z
        Case 7000
            X = 2: Y = 1
        Case 7200
            X = 3: Y = 0
        Case 9000
            X = 3: Y = 0
        Case Is > 9000
            X = 8: Y = 4
    End Select

    Static Looper
    Looper = Looper + 1
    Inst = GetWindowWord(Handle, GWW_HINSTANCE)
    Hicon = ExtractIcon(Inst, ExeFile$, Looper - 1)
    If Hicon = 0 Then
        If Looper > 0 Then
            Hicon = ExtractIcon(Inst, ExeFile$, 0)
            Looper = 1
        Else Beep: Exit Sub
        End If
    End If
    F.Pic.CLS
    Draw = DrawIcon(F.Pic.hDC, X, Y, Hicon)
End Sub

[Stop]
[10]
FormStayOnTop establishes the specified window as the topmost window no matter which window is active.

Pass it the handle of the window you want to make topmost (or for which you wish to end that condition) and a true/false flag to indicate whether it should be topmost.

[Code]
'Declares for FormStayOnTop
Declare Sub SetWindowPos Lib "User" (ByVal hWnd As Integer, ByVal hWndInsertAfter As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal cx As Integer, ByVal cy As Integer, ByVal wFlags As Integer)

Sub FormStayOnTop (Handle%, OnTop%)
Const Swp_Nosize = &H1
Const SWP_Nomove = &H2
Const Swp_NoActivate = &H10
Const Swp_ShowWindow = &H40
Const Hwnd_TopMost = -1
Const Hwnd_NoTopMost = -2

wFlags = SWP_Nomove Or Swp_Nosize Or Swp_ShowWindow Or Swp_NoActivate
Select Case OnTop%
     Case True
        PosFlag = Hwnd_TopMost
     Case False
         PosFlag = Hwnd_NoTopMost
     End Select
SetWindowPos Handle%, PosFlag, 0, 0, 0, 0, wFlags
End Sub

[Stop]
[11]
Testlength can be used to test whether more than a specified number of characters has been entered into a textbox. If so, it deletes backwards from the insertion point until the text length is within the specified limit.

[Code]
'Declares for TestLength
Global Const MB_ICONEXCLAMATION = 48

Sub TestLength (C As Control, L As Integer)
Select Case Len(C.Text)
    Case Is <= L
             Exit Sub
    Case Else
            MsgBox "This field is limited to " + Str$(L) + " characters only! ", MB_ICONEXCLAMATION, "CopyFlow"
            LeftText$ = Left$(C.Text, C.SelStart)
            RightText$ = Mid$(C.Text, C.SelStart + 1)
            LeftText$ = Left$(LeftText$, L - Len(RightText$))
            C.Text = LeftText$ + RightText$
    End Select
End Sub


[Stop]
[12]
Routine to locate the progenitor of a series of Windows
[Code]
'Declares for Find Parent
Declare Function GetParent Lib "User" (ByVal hWnd As Integer) As Integer


Function FindProgentor (WinHand As Integer) As Integer
     Parent% = GetParent(WinHand%)
     OldParent%=Parent%
     'Get the parent of the parent if any
     Do While Parent%
          OldParent% = Parent%
          Parent% = GetParent%(OldParent%)
         ' Debug.Print Parent%
     Loop
Parent%=OldParent%
FindProgenitor = Parent%
End Function

[Stop]
[13]
The Exists%() function returns a value of TRUE if the specified file exists, or FALSE if it doesn't.
[Code]
Function Exists% (F$)
On Error Resume Next
X& = FileLen(F$)
If X& Then Exists% = True
End Function

[Stop]
[14]
Function determines if passed pathname is valid

[Code]
'------------------------------------------------------
' Function:   IsValidPath as integer
' arguments:  DestPath$ a string that is a full path
' DefaultDrive$  the default drive.  eg.  "C:"
'
'  If DestPath$ does not include a drive specification,
'  IsValidPath uses Default Drive
'
'  When IsValidPath is finished, DestPath$ is reformated
'  to the format "X:\dir\dir\dir\"
'
'  Result:  True (-1) if path is valid.
'  False (0) if path is invalid
'-------------------------------------------------------

Function IsValidPath (DestPath$, ByVal DefaultDrive$) As Integer

    '----------------------------
    ' Remove left and right spaces
    '----------------------------
    DestPath$ = RTrim$(LTrim$(DestPath$))

    '-----------------------------
    ' Check Default Drive Parameter
    '-----------------------------
    If Right$(DefaultDrive$, 1) <> ":" Or Len(DefaultDrive$) <> 2 Then
        MsgBox "Bad default drive parameter specified in IsValidPath Function.  You passed,  """ + DefaultDrive$ + """.  Must be one drive letter and "":"".  For example, ""C:"", ""D:""...", 64, "Setup Kit Error"
        GoTo parseErr
    End If

    '-------------------------------------------------------
    ' Insert default drive if path begins with root backslash
    '-------------------------------------------------------
    If Left$(DestPath$, 1) = "\" Then
        DestPath$ = DefaultDrive + DestPath$
    End If

    '-----------------------------
    ' check for invalid characters
    '-----------------------------
    On Error Resume Next
    tmp$ = Dir$(DestPath$)
    If Err <> 0 Then
        GoTo parseErr
    End If

    '-----------------------------------------
    ' Check for wildcard characters and spaces
    '-----------------------------------------
    If (InStr(DestPath$, "*") <> 0) GoTo parseErr
    If (InStr(DestPath$, "?") <> 0) GoTo parseErr
    If (InStr(DestPath$, " ") <> 0) GoTo parseErr

    '------------------------------------------
    ' Make Sure colon is in second char position
    '------------------------------------------
    If Mid$(DestPath$, 2, 1) <> Chr$(58) Then GoTo parseErr

    '-------------------------------
    ' Insert root backslash if needed
    '-------------------------------
    If Len(DestPath$) > 2 Then
      If Right$(Left$(DestPath$, 3), 1) <> "\" Then
        DestPath$ = Left$(DestPath$, 2) + "\" + Right$(DestPath$, Len(DestPath$) - 2)
      End If
    End If

    '-------------------------
    ' Check drive to install on
    '-------------------------
    drive$ = Left$(DestPath$, 1)
    ChDrive (drive$)                                                        ' Try to change to the dest drive
    If Err <> 0 Then GoTo parseErr

    '-----------
    ' Add final \
    '-----------
    If Right$(DestPath$, 1) <> "\" Then
        DestPath$ = DestPath$ + "\"
    End If

    '-------------------------------------
    ' Root dir is a valid dir
    '-------------------------------------
    If Len(DestPath$) = 3 Then
        If Right$(DestPath$, 2) = ":\" Then
            GoTo ParseOK
        End If
    End If

    '------------------------
    ' Check for repeated Slash
    '------------------------
    If InStr(DestPath$, "\\") <> 0 Then GoTo parseErr

    '--------------------------------------
    ' Check for illegal directory names
    '--------------------------------------
    legalChar$ = "!#$%&'()-0123456789@ABCDEFGHIJKLMNOPQRSTUVWXYZ^_`{}~."
    BackPos = 3
    forePos = InStr(4, DestPath$, "\")
    Do
        temp$ = Mid$(DestPath$, BackPos + 1, forePos - BackPos - 1)

        '----------------------------
        ' Test for illegal characters
        '----------------------------
        For i = 1 To Len(temp$)
            If InStr(legalChar$, UCase$(Mid$(temp$, i, 1))) = 0 Then GoTo parseErr
        Next i

        '-------------------------------------------
        ' Check combinations of periods and lengths
        '-------------------------------------------
        periodPos = InStr(temp$, ".")
        length = Len(temp$)
        If periodPos = 0 Then
            If length > 8 Then GoTo parseErr                             ' Base too long
        Else
            If periodPos > 9 Then GoTo parseErr                      ' Base too long
            If length > periodPos + 3 Then GoTo parseErr        ' Extension too long
            If InStr(periodPos + 1, temp$, ".") <> 0 Then GoTo parseErr' Two periods not allowed
        End If

        BackPos = forePos
        forePos = InStr(BackPos + 1, DestPath$, "\")
    Loop Until forePos = 0

ParseOK:
    IsValidPath = True
    Exit Function

parseErr:
    IsValidPath = False

End Function


[Stop]
[15]
Creates the passed path. Create the path contained in DestPath$
First char must be drive letter, followed by
a ":\" followed by the path, if any.


[Code]
Function CreatePath (ByVal DestPath$) As Integer
    Screen.MousePointer = 11

    '---------------------------------------------
    ' Add slash to end of path if not there already
    '---------------------------------------------
    If Right$(DestPath$, 1) <> "\" Then
        DestPath$ = DestPath$ + "\"
    End If


    '-----------------------------------
    ' Change to the root dir of the drive
    '-----------------------------------
    On Error Resume Next
    ChDrive DestPath$
    If Err <> 0 Then GoTo errorOut
    ChDir "\"

    '-------------------------------------------------
    ' Attempt to make each directory, then change to it
    '-------------------------------------------------
    BackPos = 3
    forePos = InStr(4, DestPath$, "\")
    Do While forePos <> 0
        temp$ = Mid$(DestPath$, BackPos + 1, forePos - BackPos - 1)

        Err = 0
        MkDir temp$
        If Err <> 0 And Err <> 75 Then GoTo errorOut

        Err = 0
        ChDir temp$
        If Err <> 0 Then GoTo errorOut

        BackPos = forePos
        forePos = InStr(BackPos + 1, DestPath$, "\")
    Loop

    CreatePath = True
    Screen.MousePointer = 0
    Exit Function

errorOut:
    MsgBox "Error While Attempting to Create Directories on Destination Drive.", 48, "SETUP"
    CreatePath = False
    Screen.MousePointer = 0

End Function


[Stop]
[16]
Creates a Program Manager group.



[Code]
Sub CreateProgManGroup (x As Form, GroupName$, GroupPath$)
' Procedure: CreateProgManGroup
' Arguments: X           The Form where a Label1 exist
' GroupName$  A string that contains the group name
' GroupPath$  A string that contains the group file
' name  'myapp.grp'

    Screen.MousePointer = 11

    '----------------------------------------------------------------------
    ' Windows requires DDE in order to create a program group and item.
    ' Here, a Visual Basic label control is used to generate the DDE messages
    '----------------------------------------------------------------------
    On Error Resume Next


    '--------------------------------
    ' Set LinkTopic to PROGRAM MANAGER
    '--------------------------------
    x.Label1.LinkTopic = "ProgMan|Progman"
    x.Label1.LinkMode = 2
    For i% = 1 To 10                                         ' Loop to ensure that there is enough time to
      z% = DoEvents()                                       ' process DDE Execute.  This is redundant but needed
    Next                                                             ' for debug windows.
    x.Label1.LinkTimeout = 100


    '---------------------
    ' Create program group
    '---------------------
    x.Label1.LinkExecute "[CreateGroup(" + GroupName$ + Chr$(44) + GroupPath$ + ")]"


    '-----------------
    ' Reset properties
    '-----------------
    x.Label1.LinkTimeout = 50
    x.Label1.LinkMode = 0

    Screen.MousePointer = 0
End Sub



[Stop]
[17]
Creates a program manager item


[Code]
Sub CreateProgManItem (x As Form, CmdLine$, IconTitle$)

' Procedure: CreateProgManItem
'
' Arguments: X           The form where Label1 exists
'
'            CmdLine$    A string that contains the command
'                        line for the item/icon.
'                        i.e 'c:\myapp\setup.exe'
'
'            IconTitle$  A string that contains the item's
'                        caption

    Screen.MousePointer = 11

    '----------------------------------------------------------------------
    ' Windows requires DDE in order to create a program group and item.
    ' Here, a Visual Basic label control is used to generate the DDE messages
    '----------------------------------------------------------------------
    On Error Resume Next


    '---------------------------------
    ' Set LinkTopic to PROGRAM MANAGER
    '---------------------------------
    x.Label1.LinkTopic = "ProgMan|Progman"
    x.Label1.LinkMode = 2
    For i% = 1 To 10                                         ' Loop to ensure that there is enough time to
      z% = DoEvents()                                        ' process DDE Execute.  This is redundant but needed
    Next                                                     ' for debug windows.
    x.Label1.LinkTimeout = 100


    '------------------------------------------------
    ' Create Program Item, one of the icons to launch
    ' an application from Program Manager
    '------------------------------------------------
    x.Label1.LinkExecute "[AddItem(" + CmdLine$ + Chr$(44) + IconTitle$ + Chr$(44) + ",,)]"

    '-----------------
    ' Reset properties
    '-----------------
    x.Label1.LinkTimeout = 50
    x.Label1.LinkMode = 0

    Screen.MousePointer = 0
End Sub



[Stop]
[18]
Draws a 3D frame on a form. Use on a grey form.

[Code]
'Declares for Frame
Global Const HiColor = &HFFFFFF
Global Const LoColor = &H808080

Sub Frame (F As Form, l, t, h, w, Style)
Dim BigOffSet
BigOffSet = 10

'F.DrawWidth = Style
    F.DrawWidth = 1
    F.ForeColor = HiColor:  If Style = 2 Then F.ForeColor = LoColor

'bottom:
'F.Line (L + F.DrawWidth, T + H + offset)-(L + W - F.DrawWidth, T + H + offset)
    F.Line (l + F.DrawWidth, t + h)-(l + w - F.DrawWidth, t + h)

'right:
    F.Line (l + w, t + F.DrawWidth)-(l + w, t + h - F.DrawWidth)
    F.ForeColor = LoColor: If Style = 2 Then F.ForeColor = HiColor

'top:
    F.Line (l - BigOffSet + F.DrawWidth, t - BigOffSet)-(l + w + BigOffSet - F.DrawWidth, t - BigOffSet)

 'left:
    F.Line (l - BigOffSet, t + F.DrawWidth - BigOffSet)-(l - BigOffSet, t + h + BigOffSet - F.DrawWidth)

End Sub



[Stop]
[19]
obtain LoWord of Long

[Code]
Function LoWord%(LongVal&)
    LOWORD% = LongVal& AND 65535
End Function



[Stop]
[20]
obtain hiword of long

[Code]
Function HIWORD%(LongVal&)
    HIWORD% = LongVal& \ 65536 ' (note: '\', not '/')
End Function

[Stop]
[21]
Creates an Alert Box using specified text and App.Title
[Code]
Sub Alert (Mess$)
'  * creates an Alert box with an OK button
MsgBox Mess$, 48, App.Title
End Sub

[Stop]
[22]
Function creates confirmation box using specified text, returns True if Yes button pressed, False if No button pressed
[Code]
Function Confirm% (Ask$)
If MsgBox(Ask$, 52, App.Title) = 6 Then Confirm% = True
End Function

[Stop]
[23]
Draws what looks like a 3D frame around the edge of a borderless label control
[Code]
Sub Draw3dFrame (f As Form, C As Label)
'draw label size you want frame -- no autosize
'label font must be same as form font!
Const White = &HFFFFFF
Const DarkGrey = &H808080
Dim X1%, X2%, Y1%, Y2%, FrameHeight%, FrameWidth%, FrameLeft%, FrameTop%
f.DrawWidth = 1
FrameLeft% = C.Left
FrameTop% = C.Top
FrameHeight% = C.Height
FrameWidth% = C.Width
'Draw left of label
X1% = FrameLeft% - 60
X2% = FrameLeft% - 180
Y1% = FrameTop% + (f.TextHeight(C.Caption) / 2) - 60
f.ForeColor = DarkGrey
f.Line (X1%, Y1%)-(X2, Y1%)
Y1% = Y1% + 20
f.ForeColor = White
f.Line (X1%, Y1%)-(X2, Y1%)
'Draw left side
Y2% = Y1% + FrameHeight%
f.ForeColor = DarkGrey
f.Line (X2%, Y1%)-(X2%, Y2%)
X2% = X2% + 20
f.ForeColor = White
f.Line (X2%, Y1%)-(X2%, Y2%)
'draw bottom
X1% = X2%
X2% = FrameLeft% + FrameWidth%
f.ForeColor = DarkGrey
f.Line (X1%, Y2)-(X2%, Y2%)
Y2% = Y2% + 15
f.ForeColor = White
f.Line (X1%, Y2)-(X2%, Y2%)
'draw right
Y1% = FrameTop% + (f.TextHeight(C.Caption) / 2) - 60
f.Line -(X2%, Y1%)
f.ForeColor = DarkGrey
X1% = X2% - 20
f.Line (X1%, Y2% - 20)-(X1%, Y1% + 20)
'draw top to label right
X2% = FrameLeft% + f.TextWidth(C.Caption) + 60
f.Line (X1%, Y1% - 15)-(X2%, Y1% - 15)
f.ForeColor = White
f.Line (X1%, Y1%)-(X2%, Y1%)
End Sub

[Stop]
[24]
Function returns a passed path with backslash at end.

[Code]
Function FixPath$ (Test$)
'sticks a backslash on the end of test$ if there's
'not one there already
Dim T$
T$ = Test$
     If Right$(T$, 1) <> "\" Then T$ = T$ + "\"
     FixPath$ = T$
End Function


[Stop]
[25]
Function returns handle of first window matching partial name parameter


[Code]
'Declares for SearchWindowLIst
Declare Function GetWindow% Lib "USER" (ByVal hWnd%, ByVal wCmd%)
Global Const GW_HWNDFIRST = 0
Global Const GW_HWNDNEXT = 2
Declare Function GetWindowText Lib "User" (ByVal hWnd As Integer, ByVal lpString As String, ByVal aint As Integer) As Integer

Function SearchWindowList% (Cap$)
'returns handle of first window that matches partial
'caption passed to function
SearchWindowList% = 0
Dim w%, Y%, winCap As String * 255

    w% = GetWindow%(MAKerMain.hWnd, GW_HWNDFIRST)
    Do While w% <> 0
         Y% = GetWindowText(w%, winCap, 254)
         If Left$(winCap, Len(Cap$)) = Cap$ Then
            SearchWindowList% = w%
            Exit Do
         End If
        w% = GetWindow%(w%, GW_HWNDNEXT)
   Loop

End Function



[Stop]
[26]
Function removes path from fully-qualified file name, returns file name only.

[Code]
Function StripPath$ (T$)
Dim x%, ct%
StripPath$ = T$
    x% = InStr(T$, "\")
    Do While x%
       ct% = x%
       x% = InStr(ct% + 1, T$, "\")
    Loop
    If ct% > 0 Then StripPath$ = Mid$(T$, ct% + 1)
End Function


[Stop]
[27]
Trims spaces CHR$(0)'s from string returned by API function

[Code]
Function FixAPIString$ (ByVal test$)
    FixAPIString$ = Trim(Left$(test$, InStr(test$, Chr$(0)) - 1))
End Function


[Stop]
[28]
Finds and restores a previous running instance of your app
[Code]
Sub FindAndRestorePrevInstance (Cap$)
Dim X%
If App.PrevInstance Then
   AppActivate Cap$
   SendKeys ("% R")
   End
End If
End Sub

[Stop]
[29]
Open the System INI File and reads one section value

[Code]
'Declares for Get System INI-File
Value$ = GetSysINI (Section$, Key$)


'Function GetSysINI (Section$, key$) As String
'Dim retVal As String, worked As Integer

'  ' ** Open the System.INI and read the 'SECTION' out
'  retVal = String$(255, 0)
'  ' ** Standard API function to read profile string !
'  worked = GetPrivateProfileString(Section, key, "", retVal, Len(retVal), "System.ini")
'   If worked = 0 Then
'      ' ** We couldn't identify this string
'      GetSysINI = "unknown"
'   Else
'      ' ** Cut the Itemname just get the values
'      GetSysINI = Left(retVal, worked)
'   End If
'End Function

[Stop]
[30]
Opens the WIN INI File and returns one value of a specific section

[Code]
'Declares for Get Win INI-File
Value$ = GetWinINI (Section$, Key$)


'Function GetWinINI (Section$, key$) As String
'Dim retVal As String, AppName As String, worked As Integer

'  ' ** Open the System.INI and read the 'SECTION' out
'  retVal = String$(255, 0)
'  ' ** Standard API function to read profile string !
'  worked = GetProfileString(Section, key, "", retVal, Len(retVal))
'  If worked = 0 Then
'     ' ** We couldn't identify this string
'     GetWinINI = "unknown"
'  Else
'      GetWinINI = Left(retVal, worked)
'  End If
'End Function

[Stop]
[31]
Write Profile String to INI-File, must include INI-Filename

[Code]
'Declares for Write P-Profile String
R% = SaveProfile (Section$, EntryName$, EntryValue, FName$)


'Function SaveProfile (Section$, EntryName$, EntryValue, FName$) As Integer
'Dim X%

'  X% = WritePrivateProfileString%(Section$, EntryName$, Str$(EntryValue), FName$)
'  If X% = 0 Then
'      SaveProfile = False
'  Else
'      SaveProfile = True
'  End If

'End Function

[Stop]
[32]
Expanding TAB-charater and convert them to ASCii(255)

[Code]
'Declares for Expand TAB-character
R$ = ExpandTab (X1$, NumSpaces%)


'Static Function ExpandTab$ (X1$, NumSpaces%)
'Dim Tabs%, Where%, Sp%, Length%, Work$, X%
'    Tabs% = InCount%(X1$, Chr$(9))              '-> Find Number of tab Chars.
'    If Tabs% Then                               '   Are there any?
'                                                '   make room for new string
'       Work$ = Space$(Len(X1$) + 1 + (NumSpaces% - 1) * Tabs%)
'       LSet Work$ = X1$ + Chr$(0)               '-> Put existing string in it
'                                                '   and a char. 0 for later
'       Where% = 1                               '   Set search position to 1
'       For X% = 1 To Tabs%                      '-> Do each tab
'                                                '   find the next Tab character
'           Where% = InStr(Where%, Work$, Chr$(9)) + 1
'           Length% = Where% - 2                 '-> Calc length of left part
'                                                '-> Calc spaces to next tab stop
'           Sp% = Length% + NumSpaces% - (Length% Mod NumSpaces%) - Length%
'           If Where% > 1 Then Mid$(Work$, Where% - 1) = Space$(Sp%) + Mid$(Work$, Where%)
'       Next '(Insert the spaces)                 -> Assign the function looking
'                                                '   for the char. 0
'       ExpandTab$ = Left$(Work$, InStr(Work$, Chr$(0)) - 1)
'    Else                                        '-> No tabs. Just assign the
'       ExpandTab$ = X1$                          '  function
'    End If
'End Function

[Stop]
[33]
Adding leading Zeros to a number i.e:  '00000123'. Returns new Number as string !

[Code]
'Declares for Pad Function
Number$ = Pad (X!, Places%)


'Static Function Pad$ (X!, Places%)
'Dim X1$

'    X1$ = Str$(X!)                       'make a string version of the number

'    If Len(LTrim$(X1$)) > Places% Then   '  if after trimming a possible leading
'       Pad$ = "%" + X1$                                '  blank it's too long, add a "%"
'       Exit Function                                        '  to show an error and go away
'    End If

'    X1$ = Mid$(X1$, 2)                                 '  discard the leading blank or "-" sign
'    Pad$ = Mid$("-", Sgn(X!) + 2) + String$(Places% - Len(X1$) + (Sgn(X!) = -1), "0") + X1$
'                        '   ^add minus if needed           ^create the zeros                   ^less one if negative
'End Function

[Stop]
[34]
Center Form on current screen
[Code]
'Declares for Center Form on Screen
Center Form


'Sub CenterFormOld (Frm As Form)
'  ' ** Center Form on screen
'  Frm.Top = Screen.Height / 2 - Frm.Height / 2
'  Frm.Left = Screen.Width / 2 - Frm.Width / 2
'End Sub
[Stop]
[35]
Cut the last Char in Str$ if not '0'
[Code]
'Declares for Cut Last Character in Str$
NewStr$ = CutCharacter (Text$)


'Function CutCharacter (Text$) As String
' ' ** Cut the last character in a string, before we do any API-call.
' '    The string must be filled with chr(255)=space and not end with '0'.
' Text$ = RTrim$(Text$)

'  ' ** Check string
'  If Right$(Text$, 1) = Chr$(0) Then
'    ' ** Cut one character
'    Text$ = Left$(Text$, Len(Text$) - 1)
'  End If

' ' ** Store new string.
' CutCharacter$ = Text$

'End Function
[Stop]
[36]
Get DOS Version Number
[Code]
'Declares for Get DOS Version
DosVersion ()


'Function DosVersion ()
'Dim Ver As Long, DosVer As Long
'    ' ** Use API-function to get the DOS version number
'    Ver = GetVersion()
'    ' ** Calculat the long integer into short readable form
'    DosVer = Ver \ &H10000
'    DosVersion = Format((DosVer \ 256) + ((DosVer Mod 256) / 100), "Fixed")
'End Function
[Stop]
[37]
Checks if file exists in current Dir.
[Code]
'Declares for File Exist?
R% = FileExists (FILE$)


'Function FileExists (FILE$) As Integer
'  '** Check if File exist on path
'  If (Dir(FILE$) <> "") Then
'    FileExists = True
'  Else
'    FileExists = False
'  End If
'End Function
[Stop]
[38]
Checks if Filename is valid. Checks if there are any control char. Function is Flag controlled, means it can check Pathnames or Filenames depending on Flag. 1= Filename, 2=Pathname, Flag Type is Int byVal.

[Code]
'Declares for Filename is Valid?
R% = FNameIsValid (VFName$, StrFlag%)


'Function FNameIsValid (VFName$, ByVal StrFlag%) As Integer
'Dim KeyAscii%

'' ** START always positive YEAH !
' FNameIsValid = True
'  ' ** Sting is empty quit now.
'  If (VFName = "") Or (VFName = " ") Then
'     FNameIsValid = False
'     Exit Function
'  End If

'  ' ** Test Routines: check if ascii characters are OK.
'  Select Case StrFlag%
'     Case 1
'     ' ---------> Check valid FILENAME !
'      Select Case KeyAscii
'        Case Is < Asc("!")
'         FNameIsValid = False
'        Case Is > Asc("z")
'         FNameIsValid = False
'        Case Is = Asc("┤")
'         FNameIsValid = False
'        Case Is = Asc(",")
'         FNameIsValid = False
'        Case Is = Asc(":")
'         FNameIsValid = False
'        Case Is = Asc("/")
'         FNameIsValid = False
'        Case Is = Asc("\")
'         FNameIsValid = False
'      End Select
'     Case 2
'     ' ---------> Check valid PATHNAME !
'      Select Case KeyAscii
'        Case Is < Asc("!")
'         FNameIsValid = False
'        Case Is > Asc("z")
'         FNameIsValid = False
'        Case Is = Asc("┤")
'         FNameIsValid = False
'        Case Is = Asc(",")
'         FNameIsValid = False
'        Case Is = Asc(":")
'         FNameIsValid = False
'      End Select
'     Case 3
'     ' ** RESERVED for later use **
'     Case 4
'     ' ** RESERVED **
'     Case Is > 4
'     ' ---------> Illegal Call !
'     Exit Function
'     Case 0
'     ' ---------> Illegal Call, probably a bug ?
'     Exit Function
'  End Select
'End Function

[Stop]
[39]
Determine the Graphic Card by calculating the max screen resolution. Returns a number which refers to the graphic card type: 1=CGA, 2=EGA, 3=VGA, 4=HVGA, 5=SVGA....

[Code]
'Declares for Get Graphic Adapter
Card% = GetGraphicCard ()


'Function GetGraphicCard () As Integer
'Dim y%, X%

''   1.)  --> SWITCH TO TWIPS FIRST: 1 cm = 567 twips
''   2.)  --> Multiplication Factor = 15 !
''   3.)  --> Example: 480 x 15 = 7200 twips vertically
''---------------------------------------------------------------------------------
'   ' ** Make sure we are in Twips mode !
'   ScaleMode = 2
'   y% = Screen.Height ' -> Vertical Resolution
'   X% = Screen.Width ' -> Horiyontal Resolution

'    If y% = 6000 Then
'      GetGraphicCard% = 1     ' -> "CGA"
'    ElseIf y% <= 7000 Then
'      GetGraphicCard% = 2     ' -> "EGA"
'    ElseIf y% <= 7200 Then
'      GetGraphicCard% = 3     ' -> "VGA 640x480"
'    ElseIf y% > 9000 Then
'      GetGraphicCard% = 4     ' -> "VGA 800x600"
'    ElseIf y% > 11000 Then
'      GetGraphicCard% = 5     ' -> "VGA 1024x768"
'    ElseIf y% > 15000 Then
'      GetGraphicCard% = 6     ' -> "VGA 1280x1024"
'    ElseIf y% > 19000 Then
'      GetGraphicCard% = 7     ' -> "VGA 1600x1280"
'    ElseIf y% > 22000 And y% < 5000 Then
'      GetGraphicCard% = 0     ' -> "Unknown Type"
'    End If
''->  RESOLUTION: up to 1600x1280 ->  END Graphic-Adapter Test
'End Function

[Stop]
[40]
Split full Filename into Filename, Pathname, Extension, Filename w/o Extens. The function is Flag driven, 1=Drivechar, 2=Pathname, 3=full Filename, 4=Extension, 5=Patterns/Wildcards, 6=pur Filename....

[Code]
'Declares for Split Filename
Name$ = SplitFileName (ByVal FName$, ByVal GetBack%)


'Function SplitFileName (ByVal FName$, ByVal GetBack%) As String


'Dim NODrive%, NOPath%, NOFile%, NOExt%, LenF%
'Dim NameOfPath$, NameOFDrive$, NameOFPattern$
'Dim NameOFFile$, NameOFPurFile$, NameOFExt$, NameOfPathNoSL$

'' Meanings(Dim): {BS = "\"} and {PT = "."} and {DP = ":"}

'Dim BS%, PT%, DP%
'  Valid Flags (GetBack%) setting  are: 1,2,3,4,5,6,7
' ==================================================
'
'   -> 1:  Returns Drive in Letterform incl. ":" (i.e "A:").
'   -> 2:  Returns Pathname as checked Pathstring inc. "\" at the end.
'   -> 3:  Returns Filename incl. Extension (i.e: "TEST.DOC").
'   -> 4:  Returns Extension as 4 character string (i.e: ".txt").
'   -> 5:  Returns Pattern incl. Wildcards or ? (i.e: "*.EXE").
'   -> 6:  Returns pur Filename, no extension (i.e: "TEST").
'   -> 7:  Returns Pathname as checked Pathstring without "\" at end.
'
'-> STARTVALUES !
' NOPath% = False
' NODrive% = False
' NOFile% = False
' NOExt% = False
' BS% = BS1% = 0

'' ** First get the drive letter from the full Filename
' If InStr(FName$, ":") Then
'  NameOFDrive$ = Left$(FName$, 1)
'   If NameOFDrive$ <> "" And NameOFDrive$ <> " " Then
' '**********************************************
'      NameOFDrive$ = Trim$(NameOFDrive$) + ":"
' '**********************************************
'   Else
'      NameOFDrive = ""
'      NODrive = True
'   End If
' End If

' ' ** Check if there is any Path in the string represented bei "\"
' If InStr(FName$, "\") Then
'    BS% = 0
'    ' ** Find the last BackSlash in FName
'    Do
'      BS1% = BS% + 1
'      BS% = InStr(BS1%, FName$, "\")
'    Loop Until BS% = 0

'    ' ** If BS is greater then 2, we found a path, so get the name!
'    If BS1% > 2 Then
' '*******************************************
'       NameOfPath$ = Left$(FName$, BS1% - 2)
' '*******************************************
'    Else
'       NameOfPath$ = "\"
'       NOPath = True
'    End If
'    ' ** Finally we get the Filename here or we just found patterns !!
'    NameOFFile$ = Mid$(FName$, BS1%)
'    If InStr(FName$, "*") Or InStr(FName$, "?") Then
' '******************************
'       NameOFPattern$ = FName$
' '******************************
'       NOFile = True
'    End If
' Else
' '******************************
'    NameOFFile$ = FName$
' '******************************
'    NOPath = True
'    NODrive = True
' End If

' PT% = InStr(FName$, ".")
' If Len(PT%) <> 0 Then
' '***********************************
'    NameOFExt$ = Mid$(FName$, PT%)
' '***********************************
'    LenF% = Len(NameOFFile$) - 4
'    NameOFPurFile$ = Left$(NameOFFile, LenF%)
' Else
'    NameOFExt = ""
'    NOExt = True
' End If

' ' ** Check if the Pathname we found is complete or add a BS.or not.
' If Right$(NameOfPath$, 1) <> "\" Then
'    NameOfPath$ = NameOfPath$ + "\"
' End If
' If Right$(NameOfPath$, 1) = "\" Then
'    NameOfPathNoSL$ = Trim$(Right$(NameOfPath$, Len(NameOfPath$) - 1))
' End If

'  ' ** Decide what do we have to return in case of GetBack value
'  Select Case GetBack%
'   Case 1     ' --------------------[A]-> Get Driveletter ('A:')
'     SplitFileName = NameOFDrive$
'   Case 2     ' --------------------[B]-> Get checked Path ('C:\TEST\' with '\')
'     SplitFileName = NameOfPath$
'   Case 3     ' --------------------[C]-> Get Filename plus Ext ('TEST.TXT')
'     SplitFileName = NameOFFile$
'   Case 4     ' --------------------[D]-> Get Extension of File ('.DOC')
'     SplitFileName = NameOFExt$
'   Case 5     ' --------------------[E]-> Get Pattern or ? ('*.EXE or ?.?')
'     SplitFileName = NameOFPattern$
'   Case 6     ' --------------------[F]-> Get just the Filename no EXT ('TEST')
'     SplitFileName = NameOFPurFile$
'   Case 7     ' --------------------[G]-> Get Path Name ('C:\TEST' -> no '\')
'     SplitFileName = NameOfPathNoSL$
'   Case Is > 7
'     SplitFileName = FName$
'   Case Is < 1
'     SplitFileName = ""
'  End Select

'End Function

[Stop]
[41]
Get Windows System Directory

[Code]
'Declares for Get Windows Path
WinSysPath$ = SystemDirectory ()


'Function SystemDirectory () As String
'Dim WinPath As String

'' ** Use API-call to get the windows-system pathname
''    which is usually -> 'C:\WINDOW\SYSTEM' ...
'    WinPath = String(145, Chr(0))
'    SystemDirectory = Left(WinPath, GetSystemDirectory(WinPath, Len(WinPath)))
'End Function

[Stop]
[42]
Call Application and execute. Flag driven for different state of Appl.


[Code]
'Declares for Call External Application
R% = CallExtApplication (ByVal Flag%, ByVal Status%)


Function CallExtApplication (ByVal Flag%, ByVal Status%) As Integer
Dim FN$, lHnd%

'   Flags:  -> 1 = Notepad       Status: -> 1,5,9 = Normal+Focus
'                -> 2 = Calculator                      2     = Minim+Focus
'                -> 3 = Write                              3     = Maxm+Focus
'                -> 4 = ....                                  4,8   = Normal+NoFocus
'                -> 5 = ....                                  6,7   = Minim+NoFocus

   Select Case Flag%
    Case 1
    lHnd% = Shell("notepad.exe", Status%)
    Status% = 1 '-> default
    Case 2
    lHnd% = Shell("calc.exe", Status%)
    Case 3
    lHnd% = Shell("write.exe", Status%)
   End Select

 CallExtApplication = lHnd%

End Function


[Stop]
[43]
Check if '\' is there or not?
[Code]
'Declares for Check Path String ('\' ?)
Path$ = CheckPath (Pfad$)


Function CheckPath$ (Pfad$)
 ' ** Add Backslash to PathName if necessary
 If Right$(Pfad$, 1) <> "\" Then
   CheckPath$ = Pfad$ + "\"
 Else
   CheckPath$ = Pfad$
 End If
End Function
[Stop]
[44]
Clear contents of Listbox via API-call

[Code]
'Declares for Clear ListBox
ClearListBox (Ctrl As Control)


Sub ClearListBox (Ctrl As Control)
Dim X%, hWndOld%, Suc%
Const LB_RESETCONTENT = &H400 + 5

 ' ** Just backup the old handle number
 '    because we need to restore this later.
 hWndOld% = GetFocus()

 ' ** Use api-function for fast clear method.
 X% = SendMessage(agGetControlHWnd(Ctrl), LB_RESETCONTENT, 0, 0&)

 ' ** If we are successfull restore old handle.
 Suc% = APISetFocus(hWndOld%)

End Sub

[Stop]
[45]
CS File Copy routine, copies files to destination...
[Code]
'Declares for File Copy
CSFileCopy (Source$, Dest$, Copied, ErrCode%)


Static Sub CSFileCopy (Source$, Dest$, Copied, ErrCode%)
 Dim X, Path$, Count%, SrcName$, DestName$, Buffer$
    '----- Source$ may include a drive letter, a path, or wild cards
    '----- Dest$ may be a drive or path name only

    For X = Len(Source$) To 1 Step -1   'search for a "\" or ":"
        If Mid$(Source$, X, 1) = "\" Or Mid$(Source$, X, 1) = ":" Then Exit For
    Next
    Path$ = Left$(Source$, X)           'path is anything up to "\"

    If Len(Path$) And Right$(Path$, 1) <> "\" And Right$(Path$, 1) <> ":" Then
       Path$ = Path$ + "\"
    End If

    If Len(Dest$) And Right$(Dest$, 1) <> "\" And Right$(Dest$, 1) <> ":" Then
       Dest$ = Dest$ + "\"
    End If

    ErrCode = 1                     'an error here would be on the source
    Count = FCount%(Source$)        'count the number of matching files
    If DosError() Then Exit Sub     'the door was open or something
    If Count = 0 Then               'there were no matching files
       SetError 53                  'show the caller that no files matched
       Exit Sub                     'and say goodbye
    End If

    ReDim Array$(0 To Count)        'make an array to hold their names
    For X = 1 To Count              'fill with spaces
        Array$(X) = Space$(12)
    Next
    Array$(0) = Source$             'put the spec into element zero
    ReadFile Array$(0)              'and use ReadFile to get them

    Copied = 0                           'track how many are actually copied
    For X = 1 To Count                   'copy each file
        SrcName$ = Path$ + Array$(X)     'get full path for source
        DestName$ = Dest$ + Array$(X)    'get full path for dest

        FCopy SrcName$, DestName$, ErrCode% 'copy the file
        If DosError%() Then Exit For     'exit loop if an error
        Copied = Copied + 1              'show that another one was copied
    Next

    Buffer$ = ""                         'free up the memory
    Erase Array$                         '  ditto

End Sub
[Stop]
[46]
Counts numbers of def. Delimitters within a given string.

[Code]
'Declares for Delimitter
NumberOfDelimitter% = Delimit (Work$, Delim$)


Static Function Delimit% (Work$, Delim$)
Dim Counter%, X%

  Counter% = 0
   For X% = 1 To Len(Delim$)
      Counter% = Counter% + InCount%(Work$, Mid$(Delim$, X%, 1))
   Next X%
  Delimit% = Counter% '-> Return Number of Delim$.
End Function

[Stop]
[47]
Get number of current device colors (Windows system)
[Code]
'Declares for Get Color
NoColor& = DeviceColors (hDC As Integer)


Function DeviceColors (hDC As Integer) As Long
Const PLANES = 14
Const BITSPIXEL = 12
  ' ** Use the API-function to get current number of available Windows Colors.
  DeviceColors = GetDeviceCaps(hDC, PLANES) * 2 ^ GetDeviceCaps(hDC, BITSPIXEL)
End Function
[Stop]
[48]
Get File Errors and returns response number=Cancel, Ok, Retry...


[Code]
'Declares for File Errors
err = FileErrors (errVal As Integer)


Function FileErrors (errVal As Integer) As Integer


Dim MsgType%, Response%

MsgType% = MB_EXCLAIM
FileErrors = 100
' ** Reaktion depending on Error number
Select Case errVal
  Case Err_DeviceUnavailable                        ' -----> Error #68
      Msg = "(ERROR: 8100) File Error: Device not available."
      MsgType% = MB_EXCLAIM + 5
  Case Err_DiskFull                                 ' -----> Error #61
      Msg = "(ERROR: 8110) File Error: Local disk is full.."
  Case Err_DiskNotReady                             ' -----> Error #71
      Msg = "(ERROR: 8120) File Error: Device not ready."
  Case Err_DeviceIO                                 ' -----> Error #57
      Msg = "(ERROR: 8130) File Error: Device access denide."
  Case Err_BadFileName                              ' -----> Error #58
      Msg = "(ERROR: 8140) File Error: File already exist."
  Case Err_BadFileName                              ' -----> Error #52
      Msg = "(ERROR: 8150) File Error: File name is illegal."
  Case Err_PathDoesNotExist                         ' -----> Error #76
      Msg = "(ERROR: 8160) File Error: Path doesn't exist."
  Case Err_FileNotFound                             ' -----> Error #53
      Msg = "(ERROR: 8170) File Error: File was not found."
  Case Err_BadFileMode                              ' -----> Error #54
      Msg = "(ERROR: 8180) File Error: Can't open file."
  Case Err_FileAlreadyOpen                          ' -----> Error #55
      Msg = "(ERROR: 8190) File Error: File is already open."
  Case Err_InputPastEndOfFile                       ' -----> Error #62
      Msg = "(ERROR: 8195) File Error: Use of a nonstandard marker,"
  Case Else
      FileErrors = 3
      Exit Function
  End Select

  Response% = MsgBox(Msg, MsgType%, "File Error")
  Select Case Response%
     Case 4          ' Retry button.
     FileErrors = 0
     Exit Function
     Case 5          ' Ignore button.
     FileErrors = 1
     Exit Function
     Case 1, 2, 3    ' Ok and Cancel buttons.
     FileErrors = 2
     Exit Function
     Case Else       ' No idea.
     FileErrors = 3
     Exit Function
  End Select

End Function


[Stop]
[49]
Opens FName and reads all Section Header and add them to a ListBox.

[Code]
'Declares for Get INI-Section
GetIniHeaders (FiName As String, Ctrl As Control)


Sub GetIniHeaders (FiName As String, Ctrl As Control)
Dim FiNum%, IniLine$, out$

' ** After Header is found read all Items line by line
 FiNum% = FreeFile
 Open FiName For Input As FiNum%
  ' ** Read lines until end of file is reached
  Do While Not EOF(FiNum%)
     Input #FiNum%, IniLine$
     ' ** Read one line into buffer
     IniLine$ = RTrim$(LTrim$(IniLine$))
      If Left$(IniLine$, 1) = "[" Then
     ' ** Cut the breakets '[' out of the string here
     out$ = Mid$(IniLine$, 2, Len(IniLine$) - 2)
     ' ** Add item to listbox (Control = Ctrl)
     Ctrl.AddItem out$
      End If
  Loop
 Close #FiNum%
End Sub

[Stop]
[50]
Open INI FName and returns all items of sections within a ListBox.

[Code]
'Declares for Get INI items
GetIniItems (FiName As String, Head As String, Ctrl As Control)


Sub GetIniItems (FiName As String, Head As String, Ctrl As Control)
Dim FiNum%, IniLine$, out$, lo%

 ' ** Get free filenumber and clear the listbox first
 FiNum% = FreeFile
 If Ctrl.ListCount > 0 Then Ctrl.Clear

  ' ** Open *.ini file and read all header into list
  Open FiName For Input As FiNum%

  ' ** Read each line until first heading is found
  Do While (Not EOF(FiNum%)) And (IniLine$ <> "[" + Head + "]")
     ' ** Read the line into the Stringbuffer
     Input #FiNum%, IniLine$
     ' ** Cut all spaces left+right from Str$
     IniLine$ = RTrim$(LTrim$(IniLine$))
  Loop
  ' ** Do this loop for all other headings.
  ' ** Do until next heading
  If (Not EOF(FiNum%)) Then
     Do
      Input #FiNum%, IniLine$
      ' ** Trim each line to avoid empty strings
      IniLine$ = RTrim$(LTrim$(IniLine$))
      ' ** Check if first character is [ => we found a header !
      If (Left$(IniLine$, 1) <> "[") And (Len(IniLine$) > 0) Then
     ' ** Check if there is any subitem + value, we look
     '    for '=' as indicator to find it
     lo% = InStr(IniLine$, "=") - 1
     If (lo > 0) Then
        ' ** Add header to listbox if all conditions are true
        out$ = Left$(IniLine$, lo%)
        Ctrl.AddItem LTrim$(RTrim$(out$))
     End If
      End If
     ' ** Repeat all this until we reached the file-end.
     Loop While (Not EOF(FiNum%)) And (Left$(IniLine$, 1) <> "[")
  ' ** End if we reached the end of file FiNum !
  End If
  Close #FiNum%
End Sub

[Stop]
[51]
Flexible loading function, loads any filetype to a buffer var...

[Code]
'Declares for Load File to Buffer
R% =  LoadFileTObuf (FName$, Mode%, RecLen&, ControlType$)


Function LoadFileTObuf (FName$, Mode%, RecLen&, ControlType$) As Integer
Dim Num%, FNum%, Fmode%


' ** Set to true and define the Filenumber
LoadFileTObuf = True
FNum% = FreeFile
Fmode% = Mode%
On Error GoTo ERROR_FILE_LOADING

  ' ** Check what kind of action is expected
  Select Case Fmode%
     Case REPLACEFILE  ' ** OverWrite the ascii file completely
      Open FName$ For Output As FNum%
      Print #FNum%, ControlType
     Case READFILEIN     ' ** Load the file contents into control buffer
      Open FName$ For Input As FNum%
      ControlType = Input$(LOF(FNum%), FNum%)
     Case ADDTOFILE    ' ** Add text or var.-control buf to the file
      Open FName$ For Append As FNum%
      Print #FNum%, ControlType
     Case RANDOMFILE   ' ** Sequential reading of the record sets
      Open FName$ For Random As FNum% Len = RecLen
      ControlType = Input$(LOF(FNum%), FNum%)
     Case BINARYFILE   ' ** Load binary file into controle (i.e picture)
      Open FName$ For Binary As FNum%
      ControlType = Input$(LOF(FNum%), FNum%)
     Case Else
      Exit Function
  End Select
  Close FNum%
  Exit Function

ERROR_FILE_LOADING:
  LoadFileTObuf = False
    Num = FileErrors(Err)
  Resume Next
End Function

[Stop]
[52]
Extract individual components from a single string and place each element in a string array, needs delimitters to work properly.

[Code]
'Declares for Parse String
Parse (Work$, Delim$, Array$())


Sub Parse (Work$, Delim$, Array$())
Dim BeginPtr&, EndPtr&, Element&

  BeginPtr& = 1
  Element& = 1
   For EndPtr& = 1 To Len(Work$)
      If InStr(Delim$, Mid$(Work$, EndPtr&, 1)) Then
        Array$(Element&) = Mid$(Work$, BeginPtr&, EndPtr& - BeginPtr&)
        Element& = Element& + 1
        BeginPtr& = EndPtr& + 1
      End If
  Next       'Array$(1)
  '-> Store last Components to array.
  Array$(Element&) = Mid$(Work$, BeginPtr&, EndPtr& - BeginPtr&)

End Sub

[Stop]
[53]
Read File to string

[Code]
'Declares for Read File
BufStr$ = ReadFileTOstring (F$)


Function ReadFileTOstring (F$) As String
Dim FN%, indTxt%, TLine$, Buf$
On Error GoTo READ_FILE_TOSTRING_ERROR

 FN% = FreeFile              '<- Get Filenumber for F$.
 indTxt% = 0                 '<- Set line count to zero.
 TLine$ = ""                 '<- Set line buffer to 0.
 Buf$ = ""
 CL = Chr(13) + Chr(10) '<** Carriage Return and Line Feed ***
 ReadFileTOstring = ""

 Open F$ For Input As FN%     '<- Open/Input text File F$,
   Do While Not EOF(FN%)      '<- Loop until end of file (eof).
     Input #FN%, TLine$       '<- read one line into Tline$.
      'TLine$ = TLine$ + CL
     indTxt% = indTxt% + 1    '<- Get number of lines in F$.
     Buf$ = Buf$ + TLine$ + CL'<- Add text to buffer each time.
     TLine$ = ""
   Loop

 ReadFileTOstring = Buf$      '<- Copy Buf$-text to function.

 Exit Function                '<- We must exit here otherwise,
                  '   we jump into ReadError.
READ_FILE_TOSTRING_ERROR:
  R% = FileErrors(Err)        '<- Call file error function.
  ReadFileTOstring = "ERROR"  '<- Write ERROR-str$ to function.
  Resume 1013                 '<- Don't stop go to next proc.
1013 :
  indTxt% = 0                 '<- Set line count to zero.
  TLine$ = "ERROR"            '<- Set line buffer to 0.
  Buf$ = "ERROR Reading File to String"
End Function

[Stop]
[54]
Exit current appl. and restart windows.

[Code]
'Declares for Restart Windows
RestartSystem (ByVal Res As Integer)


Sub RestartSystem (ByVal Res As Integer)
Dim Res%

 Reset '-> Close all open files first.
 ' ** API restart function call
 Res% = ExitWindows(EW_RESTARTWINDOWS, 0)
End Sub

[Stop]
[55]
Pause running system for def seconds.

[Code]
'Declares for Wait - Delay
Wait (sec As Integer)


Sub Wait (sec As Integer)
Dim Count%

' The Unit of 'sec' is miliseconds [ms]
' example:
' ========
' If sec(ms)=1000 ==> Wait = 1 second !
'--------------------------------------
  For Count% = 1 To sec
  Next Count%
End Sub

[Stop]